home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 5 / skapp.zip / SKAPP.PAS < prev   
Pascal/Delphi Source File  |  1985-11-28  |  9KB  |  317 lines
  1. program SKAPP (input,output);
  2.  
  3. { programmed by O.W.Acheson 10/15/85 }
  4.  
  5. { reads SK appoint file (named in procedure readskapp, below)
  6.   selects appropriate records (dated today through today + 14 days)
  7.   prints on PRN }
  8.  
  9. type
  10.    str26   = string[26];
  11.    appoint = record
  12.                year, month, day, time : byte;
  13.                entry : str26;
  14.              end;
  15.    timerep = array[0..26] of string[7];
  16.    monrep  = array[1..12] of string[3];
  17.    TimeString = string[8];
  18.    str9 = string[9];
  19.  
  20. const
  21.    timeout : timerep = (' TITLE ','08:00am','08:30am','09:00am','09:30am','10:00am','10:30am',
  22.                      '11:00am','11:30am','12:00 n','12:30pm','01:00pm','01:30pm','02:00pm',
  23.                      '02:30pm','03:00pm','03:30pm','04:00pm','04:30pm','05:00pm','05:30pm',
  24.                      '06:00pm','06:30pm','07:00pm','07:30pm','08:00pm','08:30pm');
  25.    monthout : monrep = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug',
  26.                         'Sep','Oct','Nov','Dec');
  27.    thismonth : integer = 9;
  28.  
  29. var
  30.    appointfile : file of appoint;
  31.    appointrec : appoint;
  32.    apar : array[0..49] of appoint;
  33.    tyr,tmo,tdy,yearint,includerec,j : integer;
  34.    jultoday : real;
  35.  
  36.  
  37. {<--------------------- FUNCTION day ------------------->}
  38. FUNCTION weekday(day_of_mon,wmon,wyear : INTEGER) : str9;
  39.  
  40. TYPE
  41.    weekarr = array[0..6] of str9;
  42.  
  43. CONST
  44.    weekout : weekarr = ('Sunday','Monday','Tuesday','Wednesday',
  45.                         'Thursday','Friday','Saturday');
  46.  
  47. VAR
  48.    w,int1,int2 : integer;
  49.  
  50. begin
  51.    w := day_of_mon + (2 * wmon) + Round(int(0.6*(wmon+1))) + 1;
  52.    w := w + wyear + (wyear div 4) - (wyear div 100) + (wyear div 400);
  53.    w := w mod 7;
  54.    weekday := weekout[w];
  55. end;
  56.  
  57.  
  58. {<------------------- GetTime ------------------------>}
  59.  
  60. function GetTime : timestring;
  61.  
  62. type
  63.   regpack = record
  64.               ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
  65.             end;
  66.  
  67. var
  68.   recpack:          regpack;             {assign record}
  69.   ah,al,ch,cl,dh:   byte;
  70.   str2 : string[2];
  71.   outstr:     string[8];
  72.   i,ihour,imin,isec : integer;
  73.  
  74. begin
  75.   ah := $2c;                             {initialize correct registers}
  76.   with recpack do
  77.   begin
  78.     ax := ah shl 8 + al;
  79.   end;
  80.   intr($21,recpack);                     {call interrupt}
  81.   with recpack do
  82.   begin
  83.      ihour := cx shr 8;
  84.      imin := cx mod 256;
  85.      isec := dx shr 8;
  86.      str(ihour,str2);
  87.      if ihour < 10 then
  88.         outstr := '0'+ str2
  89.      else
  90.         outstr := str2;
  91.      str(imin,str2);
  92.      if imin < 10 then
  93.         outstr := outstr + ':0' + str2
  94.      else
  95.         outstr := outstr + ':' + str2;
  96.      str(isec,str2);
  97.      if isec < 10 then
  98.         outstr := outstr + ':0' + str2
  99.      else
  100.         outstr := outstr + ':' + str2;
  101.   end;
  102.   gettime := outstr;
  103. end;
  104.  
  105.  
  106. {<------------------- GetDate ------------------------------>}
  107.  
  108. procedure getdate(var yr,mo,day : integer);
  109.  
  110. type
  111.   DateStr = string[10];
  112.  
  113. {function Date: DateStr;}
  114. type
  115.   regpack = record
  116.               ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
  117.             end;
  118.  
  119. var
  120.   recpack:       regpack;                {record for MsDos call}
  121.  
  122. begin
  123.   with recpack do
  124.   begin
  125.     ax := $2a shl 8;                     { sets MSDOS call function }
  126.   end;
  127.   MsDos(recpack);                        { call }
  128.   with recpack do
  129.   begin
  130.    {str(cx,year);}                        {convert to string}
  131.    {str(dx mod 256,day);}                     { " }
  132.    {str(dx shr 8,month);}                         { " }
  133.     yr := cx;
  134.     day := dx mod 256;
  135.     mo := dx shr 8;
  136.   end;
  137. end;
  138.  
  139. {<------------------- Julian ----------------------->}
  140.  
  141. function julian(yy,mm,dd:integer) : real;
  142. type mtab = array[1..12] of integer;
  143. const mlook : mtab = (0,31,59,90,120,151,181,212,242,273,303,334);
  144. begin
  145.    julian := yy*365.25 + mlook[mm] + dd;
  146.    {writeln(yy:3,mm:3,dd:3,' ',mlook[mm],'  ',yy*365.25+mlook[mm]+dd);}
  147. end;
  148.  
  149. {<------------------- include ----------------------->}
  150.  
  151. function include (yr,mo,dy : integer) : boolean;
  152. var julrec : real;
  153. begin
  154.    julrec := julian(yr,mo,dy);
  155.    {write(julrec:8:2,'  ',jultoday:8:2);}
  156.    if ((julrec<jultoday) or (julrec-jultoday>14)) then
  157.       begin
  158.          include := FALSE;
  159.          {writeln(' FALSE');}
  160.       end
  161.    else
  162.       begin
  163.          include := TRUE;
  164.          {writeln(' TRUE');}
  165.       end
  166. end;
  167.  
  168. {<----------------------- READSKAPP --------------------------->}
  169.  
  170. procedure readSkapp; { reads APPOINT.APP and fills array with selected records}
  171. begin
  172.    {writeln('in readskapp');}
  173.    assign(appointfile,'A:\APPOINT.APP');
  174.    reset(appointfile);
  175.    includerec := 0;
  176.    with appointrec do
  177.    begin
  178.       while not eof(appointfile) do
  179.       begin
  180.          read(appointfile,appointrec);
  181.          yearint := year + 1900;
  182.          {writeln(monthout[month],' ',day,', ',yearint:4,' ',
  183.                timeout[time],'  ',entry);}
  184.          if (include(yearint,month,day) and (length(entry)>0)) then
  185.             begin
  186.                includerec := includerec + 1;
  187.                apar[includerec] :=  appointrec;
  188.                {writeln(includerec);}
  189.             end
  190.          else
  191.             {writeln('skipped this record');}
  192.       end;
  193.    end;
  194.    close(appointfile);
  195. end; {readskapp}
  196.  
  197. {<---------------------- SWAP ---------------------->}
  198.  
  199. procedure swap;
  200. var holdrec : appoint;
  201. begin
  202.    holdrec := apar[j+1];
  203.    apar[j+1] := apar[j];
  204.    apar[j] := holdrec;
  205. end;
  206.  
  207. {<----------------------- BACKSWAP ----------------->}
  208. procedure backswap;
  209. var backhold : integer;
  210.    more : boolean;
  211. begin
  212.     backhold := j;
  213.     j := j -1;
  214.     more := true;
  215.     while more
  216.     begin
  217.        if (apar[j].year > apar[j+1].year)
  218.                     or
  219.        ((apar[j].year = apar[j+1].year) and
  220.             (apar[j].month > apar[j+1].month))
  221.                     or
  222.        ((apar[j].year = apar[j+1].year) and
  223.             (apar[j].month = apar[j+1].month) and
  224.             (apar[j].day > apar[j+1].day))
  225.                    or
  226.        ((apar[j].year = apar[j+1].year) and
  227.             (apar[j].month = apar[j+1].month) and
  228.             (apar[j].day = apar[j+1].day) and
  229.             (apar[j].time > apar[j+1].time))
  230.                    then
  231.        begin
  232.           swap;
  233.           j := j -1;
  234.           if j = 0 then more := false;
  235.        end
  236.        else more := false;
  237.     end;
  238.     j := backhold;
  239. end;
  240.  
  241. {<------------------------ SORTARR --------------------->}
  242.  
  243. procedure sortarr;
  244. begin
  245.    for j := 1 to includerec-1 do
  246.       begin
  247.          if (apar[j].year > apar[j+1].year)
  248.                       or
  249.             ((apar[j].year = apar[j+1].year) and
  250.                  (apar[j].month > apar[j+1].month))
  251.                       or
  252.             ((apar[j].year = apar[j+1].year) and
  253.                  (apar[j].month = apar[j+1].month) and
  254.                  (apar[j].day > apar[j+1].day))
  255.                       or
  256.             ((apar[j].year = apar[j+1].year) and
  257.                  (apar[j].month = apar[j+1].month) and
  258.                  (apar[j].day = apar[j+1].day) and
  259.                  (apar[j].time > apar[j+1].time))
  260.                      then
  261.          begin
  262.             swap;
  263.             backswap;
  264.          end;
  265.       end;
  266. end;
  267.  
  268. {<--------------------- OUTPUTARR ----------------------------->}
  269.  
  270. procedure outputarr;
  271. var priorday : integer;
  272. begin
  273.    textmode(C80);
  274.    clrscr;
  275.    {textcolor(2);}
  276.    writeln(lst,'TODAY: ',weekday(tdy,tmo,tyr),
  277.            ' ',monthout[tmo],' ',tdy,', ',tyr:4,' ',gettime);
  278.    writeln(lst);
  279.    {textcolor(4);}
  280.    writeln(lst,'<---------------------------------------------------->');
  281.    writeln(lst,'Your appointments are:');
  282.    priorday := -1;
  283.    for j := 1 to includerec do
  284.    with apar[j] do
  285.    begin
  286.       if day = priorday then
  287.          writeln(lst,'    ',timeout[time],'  ',entry)
  288.       else
  289.       begin
  290.          writeln(lst);
  291.          writeln(lst,weekday(day,month,yearint),' ',
  292.                  monthout[month],' ',day,', ',yearint:4);
  293.          writeln(lst,'    ',timeout[time],'  ',entry);
  294.          priorday := day;
  295.       end;
  296.    end;
  297.    writeln;
  298.    writeln(lst,'<---------------------------------------------------->');
  299.    writeln(lst);
  300.    writeln(lst);
  301.    {textcolor(white);}
  302. end;
  303.  
  304. {<------------------------- main -------------------------------->}
  305.  
  306. begin {main}
  307.    { read file
  308.    extract appropriate records
  309.    sort into date-time order
  310.    output }
  311. getdate(tyr,tmo,tdy);
  312. jultoday := julian(tyr,tmo,tdy);
  313. readskapp;
  314. sortarr;
  315. outputarr;
  316. end. {main}
  317.